home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / PowerLisp 2.01 / PowerLisp 2.01 ƒ / Library / backquote.lisp < prev    next >
Lisp/Scheme  |  1996-05-17  |  6KB  |  214 lines
  1. ;;;
  2. ;;;        PowerLisp 2.0
  3. ;;;
  4. ;;;        Redefine the backquote facility here to handle
  5. ;;;        nested backquotes correctly.
  6. ;;;
  7. ;;;        Code from Appendix C of Guy Steele's Common Lisp, the Language,
  8. ;;;        second edition, pp. 960-967
  9. ;;;
  10.  
  11. (provide :backquote)
  12.  
  13. ;; this gets executed before the macro version of in-package is 
  14. ;; defined
  15. (eval-when (:compile-toplevel :load-toplevel :execute)
  16.     (in-package :common-lisp)) 
  17. (defvar *comma* '%COMMA)
  18. (defvar *comma-atsign* '%COMMA-ATSIGN)
  19. (defvar *comma-dot* '%COMMA-DOT)
  20. (defvar *bq-list* '%BQ-LIST)
  21. (defvar *bq-append* '%BQ-APPEND)
  22. (defvar *bq-list** '%BQ-LIST*)
  23. (defvar *bq-nconc* '%BQ-NCONC)
  24. (defvar *bq-clobberable* '%BQ-CLOBBERABLE)
  25. (defvar *bq-quote* '%BQ-QUOTE)
  26. (defvar *bq-quote-nil* (list *bq-quote* nil))
  27. #|
  28.     ;; caused these symbols to be interned to make reloading cl.lisp
  29.     ;; work better
  30. (defvar *comma* (make-symbol "COMMA"))
  31. (defvar *comma-atsign* (make-symbol "COMMA-ATSIGN"))
  32. (defvar *comma-dot* (make-symbol "COMMA-DOT"))
  33. (defvar *bq-list* (make-symbol "BQ-LIST"))
  34. (defvar *bq-append* (make-symbol "BQ-APPEND"))
  35. (defvar *bq-list** (make-symbol "BQ-LIST*"))
  36. (defvar *bq-nconc* (make-symbol "BQ-NCONC"))
  37. (defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
  38. (defvar *bq-quote* (make-symbol "BQ-QUOTE"))
  39. (defvar *bq-quote-nil* (list *bq-quote* nil))
  40. |#
  41. (set-macro-character #\`
  42.     #'(lambda (stream char)
  43.         (declare (ignore char))
  44.         (list 'backquote (read stream t nil t))))
  45.         
  46. (set-macro-character #\,
  47.     #'(lambda (stream char)
  48.         (declare (ignore char))
  49.             (case (peek-char nil stream t nil t)
  50.                 (#\@ (read-char stream t nil t)
  51.                     (list *comma-atsign* (read stream t nil t)))
  52.                 (#\. (read-char stream t nil t)
  53.                     (list *comma-dot* (read stream t nil t)))
  54.                 (otherwise (list *comma* (read stream t nil t))))))
  55.  
  56. (defparameter *bq-simplify* t)
  57.  
  58. (defmacro backquote (x)
  59.     (bq-completely-process x))
  60.                 
  61. (defun bq-completely-process (x)
  62.     (let ((raw-result (bq-process x)))
  63.         (bq-remove-tokens (if *bq-simplify*
  64.                             (bq-simplify raw-result)
  65.                             raw-result))))
  66.  
  67. (defun bq-process (x)
  68.     (cond ((atom x)
  69.             (list *bq-quote* x))
  70.           ((eq (car x) 'backquote)
  71.               (bq-process (bq-completely-process (cadr x))))
  72.           ((eq (car x) *comma*) (cadr x))
  73.           ((eq (car x) *comma-atsign*)
  74.               (error ",@~S after `" (cadr x)))
  75.           ((eq (car x) *comma-dot*)
  76.               (error ",.~S after `" (cadr x)))
  77.           (t (do ((p x (cdr p))
  78.                     (q '() (cons (bracket (car p)) q)))
  79.                  ((atom p)
  80.                   (cons *bq-append* 
  81.                           (nreconc q (list (list *bq-quote* p)))))
  82.                 (when (eq (car p) *comma*)
  83.                     (unless (null (cddr p)) (error "Malformed ,~S" p))
  84.                     (return (cons *bq-append*
  85.                         (nreconc q (list (cadr p))))))
  86.                 (when (eq (car p) *comma-atsign*)
  87.                     (error "Dotted ,@~S" p))
  88.                 (when (eq (car p) *comma-dot*)
  89.                     (error "Dotted ,.~S" p))))))
  90.                     
  91. (defun bracket (x)
  92.     (cond ((atom x)
  93.             (list *bq-list* (bq-process x)))
  94.           ((eq (car x) *comma*)
  95.               (list *bq-list* (cadr x)))
  96.           ((eq (car x) *comma-atsign*)
  97.               (cadr x))
  98.           ((eq (car x) *comma-dot*)
  99.               (list *bq-clobberable* (cadr x)))
  100.           (t (list *bq-list* (bq-process x)))))
  101.           
  102. (defun maptree (fn x)
  103.     (if (atom x)
  104.         (funcall fn x)
  105.         (let ((a (funcall fn (car x)))
  106.               (d (maptree fn (cdr x))))
  107.             (if (and (eql a (car x)) (eql d (cdr x)))
  108.                 x
  109.                 (cons a d)))))
  110.  
  111. (defun bq-splicing-frob (x)
  112.     (and (consp x)
  113.         (or (eq (car x) *comma-atsign*)
  114.             (eq (car x) *comma-dot*))))
  115.  
  116. (defun bq-frob (x)
  117.     (and (consp x)
  118.         (or (eq (car x) *comma*)
  119.             (eq (car x) *comma-atsign*)
  120.             (eq (car x) *comma-dot*))))
  121.  
  122. (defun bq-simplify (x)
  123.     (if (atom x)
  124.         x
  125.         (let ((x (if (eq (car x) *bq-quote*)
  126.                     x
  127.                     (maptree #'bq-simplify x))))
  128.             (if (not (eq (car x) *bq-append*))
  129.                 x
  130.                 (bq-simplify-args x)))))
  131.  
  132. (defun bq-simplify-args (x)
  133.     (do ((args (reverse (cdr x)) (cdr args))
  134.          (result
  135.             nil
  136.             (cond ((atom (car args))
  137.                    (bq-attach-append *bq-append* (car args) result))
  138.                   ((and (eq (caar args) *bq-list*)
  139.                         (notany #'bq-splicing-frob (cdar args)))
  140.                    (bq-attach-conses (cdar args) result))
  141.                   ((and (eq (caar args) *bq-list**)
  142.                         (notany #'bq-splicing-frob (cdar args)))
  143.                    (bq-attach-conses
  144.                         (reverse (cdr (reverse (cdar args))))
  145.                         (bq-attach-append *bq-append*
  146.                             (car (last (car args)))
  147.                             result)))
  148.                   ((and (eq (caar args) *bq-quote*)
  149.                         (consp (cadar args))
  150.                         (not (bq-frob (cadar args)))
  151.                         (null (cddar args)))
  152.                    (bq-attach-conses (list (list *bq-quote*
  153.                                                 (caadar args)))
  154.                                      result))
  155.                   ((eq (caar args) *bq-clobberable*)
  156.                    (bq-attach-append *bq-nconc* (cadar args) result))
  157.                   (t (bq-attach-append *bq-append* (car args) result)))))
  158.         ((null args) result)))
  159.  
  160. (defun null-or-quoted (x)
  161.     (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
  162.  
  163. (defun bq-attach-append (op item result)
  164.     (cond ((and (null-or-quoted item) (null-or-quoted result))
  165.            (list *bq-quote* (append (cadr item) (cadr result))))
  166.           ((or (null result) (equal result *bq-quote-nil*))
  167.            (if (bq-splicing-frob item) (list op item) item))
  168.           ((and (consp result) (eq (car result) op))
  169.            (list* (car result) item (cdr result)))
  170.           (t (list op item result))))
  171.  
  172. (defun bq-attach-conses (items result)
  173.     (cond
  174.         ((and (every #'null-or-quoted items)
  175.               (null-or-quoted result))
  176.          (list *bq-quote* (append (mapcar #'cadr items) (cadr result))))
  177.         ((or (null result) (equal result *bq-quote-nil*))
  178.          (cons *bq-list* items))
  179.         ((and (consp result)
  180.               (or (eq (car result) *bq-list*)
  181.                   (eq (car result) *bq-list**)))
  182.          (cons (car result) (append items (cdr result))))
  183.         (t (cons *bq-list** (append items (list result))))))
  184.  
  185.  
  186. (defun bq-remove-tokens (x)
  187.     (cond
  188.         ((eq x *bq-list*) 'list)
  189.         ((eq x *bq-append*) 'append)
  190.         ((eq x *bq-nconc*) 'nconc)
  191.         ((eq x *bq-list**) 'list*)
  192.         ((eq x *bq-quote*) 'quote)
  193.         ((atom x) x)
  194.         ((eq (car x) *bq-clobberable*)
  195.          (bq-remove-tokens (cadr x)))
  196.         ((and (eq (car x) *bq-list**)
  197.             (consp (cddr x))
  198.             (null (cdddr x)))
  199.          (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
  200.         (t (maptree #'bq-remove-tokens x))))
  201.  
  202.  
  203.  
  204.  
  205.  
  206.  
  207.  
  208.  
  209.  
  210.  
  211.  
  212.  
  213.  
  214.